 (************************************************************************)
 (*  Copyright(c) Filip Lundeholm 2010                                   *)
 (*          All Rights Reserved                                         *)
 (*                                                                      *)
 (*  Revision History:                                                   *)
 (*    2010-11-03    v0.2:   first public version                        *)
 (************************************************************************)

unit psopas;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Dialogs, psopas_particle, psopas_variable, fgl, Math;

const
  defaultIterations = 300;
  defaultSwarmSize = 30;

type
  TFitnessFunction = function(): double of object;
  TParticleList   = specialize TFPGList<TParticle>; // TList ?

  TPSO = class
  private
    FParticles: TParticleList;
    FVariables: TVariableList;

    FSwarmBestEverPos: TDoubleArray;
    FSwarmBestEverFitness: double;
    FFitnessFunction: TFitnessFunction;
    FShouldStop: boolean;
    FParticleCount, FIterations, FMaxIterations: integer;

    function evaluateParticle(particle: TParticle): double;
    procedure init();
    procedure updateVariables(var pos: TDoubleArray);
  public
    constructor Create(const fitnessFunction: TFitnessFunction); overload;
    destructor Destroy(); overload;
    procedure setParticleCount(NumberOfParticles: integer);

    procedure add(var variable: double);
    procedure add(var variable: integer);
    procedure add(var variable: byte);
    procedure add(var variable: double; min, max: double);
    procedure add(var variable: integer; min, max: integer);
    procedure add(var variable: byte; min, max: byte);

    procedure optimize(maximumIterations: integer=defaultIterations);
    function getBestFitness(): double;
    procedure stop();
    procedure updateVariablesToBest();

  end;

implementation

constructor TPSO.Create(const fitnessFunction: TFitnessFunction); overload;
begin
  FParticleCount := defaultSwarmSize;
  FFitnessFunction := fitnessFunction;
  FParticles := TParticleList.Create();
  FVariables := TVariableList.Create();
end;



destructor TPSO.Destroy();
var
  i: integer;
begin
  for i := 1 to FParticleCount do
  begin
    FParticles[i].Free;
  end;

  for i := 1 to FVariables.Count do
  begin
    FVariables[i].Free;
  end;
  inherited Destroy;
end;

procedure TPSO.setParticleCount(NumberOfParticles: integer);
begin
  if not FShouldStop then
  begin
    FParticleCount := NumberOfParticles;
  end;
end;

// ------- add---------

procedure TPSO.add(var variable: double);
begin
  if not FShouldStop then
    FVariables.add(TVariable.Create(variable));
end;

procedure TPSO.add(var variable: integer);
begin
  if not FShouldStop then
    FVariables.add(TVariable.Create(variable));
end;

procedure TPSO.add(var variable: byte);
begin
  if not FShouldStop then
    FVariables.add(TVariable.Create(variable));
end;

procedure TPSO.add(var variable: double; min, max: double);
var
  v: TVariable;
begin
  if not FShouldStop then
  begin
    v     := TVariable.Create(variable);
    v.min := min;
    v.max := max;
    FVariables.add(v);
  end;
end;

procedure TPSO.add(var variable: integer; min, max: integer);
var
  v: TVariable;
begin
  if not FShouldStop then
  begin
    v     := TVariable.Create(variable);
    v.min := min;
    v.max := max;
    FVariables.add(v);
  end;
end;

procedure TPSO.add(var variable: byte; min, max: byte);
var
  v: TVariable;
begin
  if not FShouldStop then
  begin
    v     := TVariable.Create(variable);
    v.min := min;
    v.max := max;
    FVariables.add(v);
  end;
end;

// --------------------------------

procedure TPSO.init();
var
  i: integer;
  p: TParticle;
begin
  randomize();
  FSwarmBestEverFitness := Math.MinDouble;

  if FParticles.Count > 0 then
  begin
    for i := 0 to FParticles.Count - 1 do
    begin
      FParticles[i].Free;
    end;
    FParticles.Clear;
  end;

  for i := 1 to FParticleCount do
  begin
    p := TParticle.Create(FVariables, FMaxIterations);
    FParticles.add(p);
  end;

  FParticles[0].getPosition(FSwarmBestEverPos);
end;

procedure TPSO.updateVariables(var pos: TDoubleArray);
var
  i: integer;
begin
  for i := 0 to length(pos) - 1 do
  begin
    FVariables[i].setValue(pos[i]);
  end;
end;

function TPSO.evaluateParticle(particle: TParticle): double;
var
  pos:     TDoubleArray;
  fitness: double;
begin
  pos := particle.getPosition();
  updateVariables(pos);
  fitness := FFitnessFunction();
  particle.setFitness(fitness);

  Result := fitness;
end;



procedure TPSO.optimize(maximumIterations: integer=defaultIterations);
var
  swarmBest, p: TParticle;
  swarmBestFitness, fitness: double;
  i: integer;
begin
  FMaxIterations := maximumIterations;
  if not FShouldStop then
  begin
    FShouldStop := False;
    FIterations := 0;
    init();

    while (not FShouldStop) and (FIterations < FMaxIterations) do
    begin
      Inc(FIterations);
      swarmBest := nil;
      swarmBestFitness := Math.MinDouble;

      // evaulate particles
      for i := 0 to FParticles.Count - 1 do
      begin
        p := FParticles[i];
        fitness := evaluateParticle(p);

        if fitness > swarmBestFitness then
        begin
          swarmBestFitness := fitness;
          swarmBest := p;
        end;

        if FShouldStop then
        begin
          break;
        end;
      end;

      // update global best
      if swarmBestFitness > FSwarmBestEverFitness then
      begin
        FSwarmBestEverFitness := swarmBestFitness;
        swarmBest.getPosition(FSwarmBestEverPos);
      end;

      // update all FParticles
      for i := 0 to FParticles.Count - 1 do
      begin
        FParticles[i].update(FSwarmBestEverPos);
      end;
    end;  // end of main loop


    // finish with global best found
    updateVariablesToBest();
  end;
end;

procedure TPSO.updateVariablesToBest();
begin
  updateVariables(FSwarmBestEverPos);
end;

function TPSO.getBestFitness(): double;
begin
  Result := FSwarmBestEverFitness;
end;

procedure TPSO.stop();
begin
  FShouldStop := True;
end;

end.

